home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / glob.scm < prev    next >
Text File  |  1995-10-13  |  9KB  |  273 lines
  1. ;;; Code for processing file names with a glob pattern.
  2.  
  3. ;;; Copyright (c) 1994 by David Albertz (dalbertz@clark.lcs.mit.edu).
  4. ;;; Copyright (c) 1994 by Olin Shivers   (shivers@clark.lcs.mit.edu).
  5.  
  6. ;;; This code is freely available for use by anyone for any purpose,
  7. ;;; so long as you don't charge money for it, remove this notice, or
  8. ;;; hold us liable for any results of its use.  --enjoy.
  9.  
  10. ;;; Usage:    (glob pattern-list)
  11. ;;;                 pattern-list := a list of glob-pattern strings
  12.  
  13. ;;; Return:    list of file names (strings)
  14. ;;;             The files "." and ".." are never returned by glob.
  15. ;;;             Dot files will only be returned if the first character
  16. ;;;             of a glob pattern is a ".".
  17.  
  18. ;;; The empty pattern matches nothing.
  19. ;;; A pattern beginning with / starts at root; otherwise, we start at cwd.
  20. ;;; A pattern ending with / matches only directories, e.g., "/usr/man/man?/"
  21.  
  22. (define (glob . pattern-list)
  23.   ;; Expand out braces, and apply GLOB-ONE-PATTERN to all the result patterns.
  24.   (apply append
  25.      (map glob-one-pattern
  26.           (apply append (map glob-remove-braces pattern-list)))))
  27.  
  28.  
  29. (define (glob-one-pattern pattern)
  30.   (let ((plen (string-length pattern)))
  31.     (if (zero? plen) '()
  32.     (let ((directories-only? (char=? #\/ (string-ref pattern (- plen 1))))
  33.           (patterns (split-file-name pattern))) ; Must be non-null.
  34.       (if (equal? "" (car patterns))
  35.           (really-glob ""   (cdr patterns) directories-only?)    ; root
  36.           (really-glob "."  patterns       directories-only?))))))    ; cwd
  37.  
  38.  
  39. (define (really-glob root-file patterns directories-only?)
  40.   ;; This is the heart of the matcher.
  41.   (let recur ((file root-file)
  42.           (pats patterns)
  43.           (sure? #f))    ; True if we are sure this file exists.
  44.     (if (pair? pats)
  45.     (let ((pat (car pats))
  46.           (pats (cdr pats))
  47.           (dir (file-name-as-directory file)))
  48.       (receive (winners sure?) (glob-subpat file pat)
  49.         (apply append (map (lambda (f)
  50.                  (recur (string-append dir f) pats sure?))
  51.                    winners))))
  52.  
  53.     ;; All done.
  54.     (if directories-only?
  55.         (if (maybe-isdir? file)
  56.         (list (file-name-as-directory file))
  57.         '())
  58.         (if (or sure? (file-exists? file))
  59.         (list file)
  60.         '())))))
  61.  
  62.  
  63. ;;; Return the elts of directory FNAME that match pattern PAT.
  64. ;;; If PAT contains no wildcards, we cheat and do not match the
  65. ;;; constant pattern against every file in FNAME/; we just 
  66. ;;; immediately return FNAME/PAT. In this case, we indicate that we 
  67. ;;; aren't actually sure the file exists by returning a true SURE?
  68. ;;; value. Not only does this vastly speed up the matcher, it also
  69. ;;; allows us to match the constant patterns "." and "..".
  70.  
  71. (define (glob-subpat fname pat) ; PAT doesn't contain a slash.
  72.   (cond ((string=? pat "") (values '() #t))
  73.  
  74.     ((constant-glob? pat)
  75.      (values (cons pat '()) #f)) ; Don't check filesys.
  76.     
  77.     (else (let* ((dots? (char=? #\. (string-ref pat 0))) ; Match dot files?
  78.              (candidates (maybe-directory-files fname dots?))
  79.              (re (make-regexp (glob->regexp pat))))
  80.         (values (filter (lambda (f) (regexp-exec re f)) candidates)
  81.             #t))))) ; These guys exist for sure.
  82.  
  83. ;;; The initial special-case above isn't really for the fast-path; it's
  84. ;;; an obscure and unlikely case. But since we have to check pat[0] for an 
  85. ;;; initial dot, we have to do the check anyway...
  86.  
  87.  
  88. ;;; Translate a brace-free glob pattern to a regular expression.
  89.  
  90. (define (glob->regexp pat)
  91.   (let ((pat-len (string-length pat)))
  92.     (let lp ((result '(#\^))
  93.          (i 0)
  94.          (state 'normal))
  95.       (if (= i pat-len)
  96.  
  97.       (if (eq? state 'normal)
  98.           (list->string (reverse (cons #\$ result)))
  99.           (error "Illegal glob pattern" pat))
  100.  
  101.  
  102.       (let ((c (string-ref pat i))
  103.         (i (+ i 1)))
  104.         (case state
  105.           ((char-set)
  106.            (lp (cons c result)
  107.            i
  108.            (if (char=? c #\]) 'normal 'char-set)))
  109.  
  110.           ((escape)
  111.            (lp (case c
  112.              ((#\$ #\^ #\. #\+ #\? #\* #\| #\( #\) #\[)
  113.               (cons c (cons #\\ result)))
  114.              (else (cons c result)))
  115.            i
  116.            'normal))
  117.  
  118.           ;; Normal
  119.           (else (case c
  120.               ((#\\) (lp result i 'escape))
  121.               ((#\*) (lp (cons #\* (cons #\. result)) i 'normal))
  122.               ((#\?) (lp (cons #\. result) i 'normal))
  123.               ((#\[) (lp (cons c result) i 'char-set))
  124.               ((#\$ #\^ #\. #\+ #\|  #\( #\))
  125.                      (lp (cons c (cons #\\ result)) i 'normal))
  126.               (else  (lp (cons c result) i 'normal))))))))))
  127.  
  128.  
  129. ;;; Is the glob pattern free of *'s, ?'s and [...]'s?
  130. (define (constant-glob? pattern)
  131.   (let ((patlen (string-length pattern)))
  132.     (let lp ((i 0)
  133.          (escape? #f))    ; Was last char an escape char (backslash)?
  134.       (if (= i patlen)
  135.  
  136.       (if escape?
  137.           (error "Ill-formed glob pattern" pattern)
  138.           #t)
  139.  
  140.       (let ((next-i (+ i 1)))
  141.         (if escape? (lp next-i #f)
  142.         (case (string-ref pattern i)
  143.           ((#\* #\? #\[) #f)
  144.           ((#\\) (lp next-i #t))
  145.           (else  (lp next-i #f)))
  146.         (lp next-i #f)))))))
  147.  
  148.  
  149. ;;; Make an effort to get the files in the putative directory PATH.
  150. ;;; If PATH isn't a directory, or some filesys error happens (such
  151. ;;; as a broken symlink, or a permissions problem), don't error out,
  152. ;;; just quietly return the empty list.
  153.  
  154. (define (maybe-directory-files path dotfiles?)
  155.   (with-errno-handler ((errno data)
  156.                (else '()))    ; On any error, return ().
  157.     (directory-files path dotfiles?)))
  158.  
  159. ;;; Make an effort to find out if the file is a directory. If there's
  160. ;;; any error, return #f.
  161.  
  162. (define (maybe-isdir? path)
  163.   (with-errno-handler ((errno data)
  164.                (else #f))    ; On any error, return #f.
  165.     (file-directory? path)))
  166.  
  167.  
  168.  
  169. ;;; This section of code is responsible for processing the braces in glob
  170. ;;; patterns. I.e., "{foo,bar}/*.c" -> ("foo/*.c" "bar/*.c")
  171. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  172.  
  173. (define (append-suffix strs suffix)
  174.   (map (lambda (s) (string-append s suffix)) strs))
  175.  
  176. (define (cross-append prefixes suffixes)
  177.   (apply append (map (lambda (sfx) (append-suffix prefixes sfx)) suffixes)))
  178.  
  179. ;;; Parse a glob pattern into an equivalent series of brace-free patterns.
  180. ;;; The pattern starts at START and is terminated by (1) end of string,
  181. ;;; (2) an unmatched close brace, or (3) a comma (if COMMA-TERMINATES? is set).
  182. ;;; Returns two values:
  183. ;;; - the list of patterns
  184. ;;; - the string index after the pattern terminates. This points at
  185. ;;;   the comma or brace if they terminated the scan, since they are
  186. ;;;   not part of the pattern.
  187.  
  188. (define (parse-glob-braces pattern start comma-terminates?)
  189.   (let ((pattern-len (string-length pattern))
  190.     (finish (lambda (prefixes pat)
  191.           (append-suffix prefixes (list->string (reverse pat))))))
  192.  
  193.     (let lp ((i start)
  194.          (prefixes '(""))
  195.          (pat '()))
  196.       (if (= i pattern-len)
  197.       (values (finish prefixes pat) i)
  198.       
  199.       (let ((c (string-ref pattern i)))
  200.         (case c
  201.           ((#\{)
  202.            (let ((prefixes (append-suffix prefixes 
  203.                           (list->string (reverse pat)))))
  204.          (receive (pats i)
  205.              (parse-comma-sequence pattern (+ i 1))
  206.            (lp i (cross-append prefixes pats) '()))))
  207.           ((#\\)
  208.            (let ((i (+ i 1)))
  209.          (if (= i pattern-len)
  210.              (error "Dangling escape char in glob pattern" pattern)
  211.              (lp (+ i 1)
  212.              prefixes
  213.              (cons (string-ref pattern i) pat)))))
  214.           ((#\,)
  215.            (if comma-terminates?
  216.            (values (finish prefixes pat) i)
  217.            (lp (+ i 1) prefixes (cons c pat))))
  218.  
  219.           ((#\})
  220.            (values (finish prefixes pat) i))
  221.  
  222.           (else
  223.            (lp (+ i 1) prefixes (cons c pat)))))))))
  224.  
  225.  
  226. ;;; Parse the internals of a {foo,bar,baz} brace list from a glob pattern.
  227. ;;; START is the index of the char following the open brace.
  228. ;;; Returns two values:
  229. ;;; - an equivalent list of brace-free glob patterns
  230. ;;; - the index of the char after the terminating brace
  231.  
  232. (define (parse-comma-sequence pattern start)
  233.   (let ((pattern-len (string-length pattern)))
  234.     (let lp ((i start)
  235.          (patterns '()))    ; The list of comma-separated patterns read.
  236.  
  237.       (if (= i pattern-len)
  238.       (error "Glob brace-expression pattern not terminated" pattern)
  239.       (receive (pats i) (parse-glob-braces pattern i #t)
  240.         (let ((patterns (append patterns pats)))
  241.           (if (= i pattern-len)
  242.           (error "Unterminated brace in glob pattern" pattern)
  243.           (let ((c (string-ref pattern i)))
  244.             (case c
  245.               ((#\})
  246.                (values patterns (+ i 1)))
  247.               ((#\,)
  248.                (lp (+ i 1) patterns))
  249.               (else
  250.                (error "glob parser internal error" pattern i)))))))))))
  251.  
  252. (define (glob-remove-braces pattern)
  253.   (receive (pats i) (parse-glob-braces pattern 0 #f)
  254.     (if (= i (string-length pattern)) pats
  255.     (error "Unmatched close brace in glob pattern" pattern i))))
  256.  
  257. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  258.  
  259. ;;; Convert a string into a glob pattern that matches that string exactly --
  260. ;;; in other words, quote the \ * ? [] and {} chars with backslashes.
  261. (define (glob-quote string)
  262.   (let lp ((i (- (string-length string) 1))
  263.        (result '()))
  264.     (if (< i 0) (list->string result)
  265.     (lp (- i 1)
  266.         (let* ((c (string-ref string i))
  267.            (result (cons c result)))
  268.           (if (memv c '(#\[ #\] #\* #\? #\{ #\} #\\))
  269.           (cons #\\ result)
  270.           result))))))
  271.  
  272.  
  273.